Уравнения Cosgrove

Следующие скалярные уравнения обладают свойством Пенлеве [C.M. Cosgrove. Stud. Appl. Math. 104:1 (2000) 1–65; 116:4 (2006) 321–413]:

F-V: 	   (y^((4)))=20y y''+10(((y'))^2)-40(y^3)+α y+κ x+β,			{KdV, string eq}

F-VI: 	   (y^((4)))=18y y''+9(((y'))^2)-24(y^3)+α (y^2)+(1/9)(α^2)y+κ x+β.		{Bsq}

Fif-I:       Derivative[5][y]=15y y'''+(75/2)y'y''-45 (y^2)y'+(λ x+α)y'+2λ y,		{KK}

Fif-II:      Derivative[5][y]=30y y'''+30y'y''-180 (y^2)y'+(λ x+α)y'+2λ y,		{SK}

Fif-III:     Derivative[5][y]=20y y'''+40y'y''-120 (y^2)y'+(λ x+α)y'+2λ y+κ,	{KdV}

Fif-IV:     (D-(x^(-1)))((y^((4)))-18y y''-9(((y'))^2)+24(y^3)-3λ y'+κ)=(1/2)λ x (5y'''-36 y y')-(1/2)(λ^2)x (2x y'+y).

F-XVII:     (y^((4)))=10(y^2)y''+10y (((y'))^2)-6(y^5)-10δ(y''-2(y^3))+(λ x+μ) y+γ,	{mKdV}

F-XVIII:    (y^((4)))=-5y'y''+5(y^2)y''+5y (((y'))^2)-(y^5)+(λ x+α) y+γ.			{mSKKK}

Главная часть у них однородна относительно весов ρ(y)=2,ρ(D)=1. В скобках написано, из каких уравнений они получаются редукциями. Один из вопросов – имеются ли матричные аналоги. Отметим, что, вроде бы, разумных аналогов KK и SK не существует, но это не означает, что их не может быть на уровне ОДУ.

F5=-Derivative[4][y][x]+20y[x]y''[x]+10((y'[x])^2)-40((y[x])^3)+α y[x]+κ x+β;
F6=-Derivative[4][y][x]+18y[x]y''[x]+9((y'[x])^2)-24((y[x])^3)+α ((y[x])^2)+((α^2)/9) y[x]+κ x+β;

Fif1= -Derivative[5][y][x]+15y[x]y'''[x]+(75/2)y'[x]y''[x]-45((y[x])^2)y'[x]+(λ x+α)y'[x]+2λ y[x];
Fif2= -Derivative[5][y][x]+30y[x]y'''[x]+30y'[x]y''[x]-180((y[x])^2)y'[x]+(λ x+α)y'[x]+2λ y[x];


Fif3= -Derivative[5][y][x]+20y[x]y'''[x]+40y'[x]y''[x]-120((y[x])^2)y'[x]+(λ x+α)y'[x]+2λ y[x]+κ;

Fif3b= -Derivative[5][y][x]+20y[x]y'''[x]+40y'[x]y''[x]-120((y[x])^2)y'[x]+α y'[x]+1/x(Derivative[4][y][x]-20y[x]y''[x]-10((y'[x])^2)+40((y[x])^3)-α y[x]-β);


Fif4= -Derivative[5][y][x]+18y[x]y'''[x]+36y'[x]y''[x]-72((y[x])^2)y'[x]+3λ y''[x]+1/x(Derivative[4][y][x]-18y[x]y''[x]-9((y'[x])^2)+24((y[x])^3)-3λ y'[x]+κ)+
1/2λ x(5y'''[x]-36 y[x]y'[x])-1/2(λ^2) x(2x y'[x]+y[x]);

Fif4b= -Derivative[5][y][x]+18y[x]y'''[x]+36y'[x]y''[x]-72((y[x])^2)y'[x]+2α y[x]y'[x]+1/9(α^2)y'[x]+κ;

Fif4c= -Derivative[5][y][x]+18y[x]y'''[x]+36y'[x]y''[x]-72((y[x])^2)y'[x]+2α y[x]y'[x]+1/9(α^2)y'[x]+1/x(Derivative[4][y][x]-18y[x]y''[x]-9((y'[x])^2)+24((y[x])^3)-α ((y[x])^2)-1/9(α^2)y[x]-β);


F17=-Derivative[4][y][x]+10((y[x])^2)y''[x]+10y[x]((y'[x])^2)-6((y[x])^5)-10δ(y''[x]-2((y[x])^3))+(λ x+μ)y[x]+γ;
F18=-Derivative[4][y][x]-5y'[x]y''[x]+5((y[x])^2)y''[x]+5y[x]((y'[x])^2)-((y[x])^5)+(λ x+α)y[x]+γ;

Подстановки

Fif3b+(D[#,x]-#/x)&[Derivative[4][y][x]-20y[x]y''[x]-10((y'[x])^2)+40((y[x])^3)-α y[x]-β]
Expand[Fif3b-D[F5,x]+F5/x]

-Fif4-(D[#,x]-#/x)&[Derivative[4][y][x]-18y[x]y''[x]-9((y'[x])^2)+24((y[x])^3)-3λ y'[x]+κ]+
1/2λ x(5y'''[x]-36 y[x]y'[x])-1/2(λ^2) x(2x y'[x]+y[x])

Fif4b+D[Derivative[4][y][x]-18y[x]y''[x]-9((y'[x])^2)+24((y[x])^3)-α ((y[x])^2)-1/9(α^2)y[x]-κ x-β,x]
Fif4b-D[F6,x]

Fif4c+(D[#,x]-#/x)&[Derivative[4][y][x]-18y[x]y''[x]-9((y'[x])^2)+24((y[x])^3)-α ((y[x])^2)-1/9(α^2)y[x]-β]
Expand[Fif4c-D[F6,x]+F6/x]

Преобразования Миуры F-XVII → Fif-III

feq=F17/.y->f

M1=Derivative[k_][f][x]:> D[((f[x])^2)-2 y[x]-δ,{x,k-1}];
Collect[D[feq,x]//.M1 ,f[x],Factor];
Expand[D[%,x]/2-f[x]%//.M1 ]
Expand[%+Fif3/.{κ->δ λ,α->30(δ^2)+μ}]

M2=Derivative[k_][f][x]:> D[-((f[x])^2)+2 y[x]+δ,{x,k-1}];
Collect[D[feq,x]//.M2 ,f[x],Factor];
Expand[-D[%,x]/2-f[x]%//.M2 ]
Expand[%+Fif3/.{κ->δ λ,α->30(δ^2)+μ}]

Преобразования Миуры Fif-II ← F-XVIII → Fif-I

feq=F18/.y->f

M1=Derivative[k_][f][x]:> D[(((f[x])^2)-3 y[x])/2,{x,k-1}];
Collect[D[feq,x]//.M1 ,f[x],Factor];
Expand[-2/3(D[%,x]-f[x]%)//.M1]
Expand[%-Fif1]

M2=Derivative[k_][f][x]:> D[-((f[x])^2)+6 y[x],{x,k-1}];
Collect[D[feq,x]//.M2 ,f[x],Factor];
Expand[(D[%,x]+2 f[x]%)/6//.M2]
Expand[%-Fif2]

Морковка F-VI  -24(y^3)+α (y^2)+(1/9)(α^2)y+κ x+β=0

Manipulate[
ParametricPlot[{(1/9) (α^2) y+α (y^2)-24 (y^3),y},{y,-5,5},PlotRange->{{-10,10},{-5,5}},
AspectRatio->Automatic],
{{α,0},-10,10,Appearance->"Labeled"}]

Fif-I, II, III в виде системы

Рассмотрим систему

(1) 	u''=6(u^2)+x-2g,   2g g''=(((g'))^2)+2(a u+b)(g^2)-(c^2)

или, в продифференцированном виде

(1') 	u''=6(u^2)+x-2g,   g'''=2(a u+b)g'+a u' g.

После исключения g, (1') сводится к уравнению

(2) 	Derivative[5][u]=2((a+6)u+b)u'''+(a+36)u'u''-30a (u^2)u'-24b u u'-a x u'-2a u-2b.

equg1=-u''[x]+6((u[x])^2)+x-2g[x]
equg2=-2g[x]g''[x]+((g'[x])^2)+2(a u[x]+b)((g[x])^2)-(c^2)
equg3=Collect[D[equg2,x]/(2g[x]),g'[x],Factor]
gu=Solve[equg1==0,g[x]][[1]]
equ=Collect[-2equg3/.D[gu,x,x,x]/.D[gu,x]/.gu,{Derivative[5][u][x],Derivative[3][u][x],u''[x]},Factor]

С точностью до простых замен, получаем

Expand[{
(equ/.{a->3/2, b->0,u[x]->y[x],Derivative[j_][u][x]:>Derivative[j][y][x]})-(Fif1/.{λ->-3/2, α->0}),
(2equ/.{a->24, b->0,u[x]->y[x]/2,Derivative[j_][u][x]:>Derivative[j][y][x]/2})-(Fif2/.{λ->-24, α->0}),
(equ/.{a->4,u[x]->y[x]-b/10,Derivative[j_][u][x]:>Derivative[j][y][x]})-(Fif3/.{λ->-4, α->6/5(b^2), κ->-6/5b})
}]

Тест Ковалевской-Пенлеве (символ P2)

Классификация полиномиальных уравнений в общем виде, конечно, сложна, но, если вид уже определен с точностью до констант, то все довольно просто. При

.  Тест для уравнений порядка 4

(y^((4)))=a y y''+b (((y'))^2)+c (y^3)+(Subscript[k, 1])y y'+(Subscript[k, 2]) (y^2)+(Subscript[k, 3])y'+(Subscript[k, 4])y+(Subscript[k, 5])x+(Subscript[k, 6])

Делаем разложение в 0, свободный член играет роль дополнительной постоянной, кроме него еще три должно быть.

Clear[r,a,b,c,k]
m=30;
Y=(1/(x^2))+Sum[r[n](x^n),{n,-1,m}];

eq=-Derivative[4][y][x]+a y[x]y''[x]+b ((y'[x])^2)+c ((y[x])^3)+
k[0]y'''[x]+k[1]y[x]y'[x]+k[2]((y[x])^2)+k[3]y'[x]+k[4]y[x]+k[5]x+k[6]

eqq=eq/.{y[x]->Y,Derivative[n_][y][x]:>D[Y,{x,n}]};

Coefficient[eqq,x,-7]
Factor[Coefficient[eqq,x,-6]]

Factor[Coefficient[eq/.{y[x]->p/(x^2),Derivative[n_][y][x]:>D[p/(x^2),{x,n}]},(x^(-6))]]
Factor[%/.c->(120-6 a-4 b)]

Eq=eq/.c->(120-6 a-4 b)
M=10;
Meqs=M+6;
eqs=Table[Collect[Coefficient[eqq/.c->(120-6 a-4 b),x,n],r[n+4],Factor],{n,-5,M}];
Take[eqs,5]

lc=Table[Factor[D[Coefficient[eqq/.c->(120-6 a-4 b),x,n],r[n+4]]],{n,-5,M}]
Length[lc]-Meqs

rvar=Table[r[n],{n,-1,M+4}]
kvar=Table[k[n],{n,0,5}]

Нас интересуют точки пересечения трех прямых.

lines=Factor[lc]

points=Reap[Do[ss=Solve[{lines[[i]],lines[[j]],lines[[k]]}==0,{a,b}];
If[ss=={},,Sow[{{a,b},{i,j,k}}/.ss[[1]]]],{i,1,Meqs},{j,i+1,Meqs},{k,j+1,Meqs}]][[2,1]]

P=Length[points]

ContourPlot[lines==0,{a,5,60},{b,-40,40},
ContourStyle->Black,
ImageSize->400,
RotateLabel->False,
FrameLabel->{
Style["a",FontSize->20,FontFamily->"Times",FontSlant->Italic],
Style["b",FontSize->20,FontFamily->"Times",FontSlant->Italic]},
Epilog->{Blue,PointSize[0.025],Point[#[[1]]]&/@{points[[6]],points[[8]],
points[[10]],points[[11]],points[[12]]},
Red,PointSize[0.015],Point[#[[1]]]&/@points
}
]

Cлучай 1: пусто

case=1;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}];
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 2: пусто

case=2;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 3: пусто

case=3;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 4: пусто

case=4;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 5: пусто

case=5;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 6: F-IV

case=6;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];

gg=GroebnerBasis[%,kvar]

Solve[gg==0,kvar]
Eq/.abru/.%[[1]]

Cлучай 7: пусто

case=7;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 8: F-V

case=8;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Solve[gg==0,kvar]
Eq/.abru/.%[[1]]

Cлучай 9: пусто

case=9;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 10: F-VI

case=10;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Solve[gg==0]
Eq/.abru/.%[[1]]

Cлучай 11: F-III

case=11;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Solve[gg==0]
Eq/.abru/.%[[1]]

Cлучай 12: F-I.....

case=12;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[6]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Solve[gg==0]
Eq/.abru/.%[[1]]

.  Тест для уравнений порядка 5

(y^((5)))=a y y'''+b y'y''+c (y^2)y'+(Subscript[k, 1])x y'+(Subscript[k, 2]) y'+(Subscript[k, 3])y+(Subscript[k, 4])

Делаем разложение в 0, параметр (Subscript[k, 2]) играет роль дополнительной постоянной, кроме него еще четыре должно быть.

Clear[r,a,b,c,k]
m=30;
Y=(1/(x^2))+Sum[r[n](x^n),{n,-1,m}];

eq=-Derivative[5][y][x]+a y[x]y'''[x]+b y'[x]y''[x]+c ((y[x])^2)y'[x]+
k[1]x y'[x]+k[2]y'[x]+k[3]y[x]+k[4]

eqq=eq/.{y[x]->Y,Derivative[n_][y][x]:>D[Y,{x,n}]};

Coefficient[eqq,x,-8]
Factor[Coefficient[eqq,x,-7]]

Eq=eq/.c->360-12 a-6 b
M=10;
Meqs=M+7;

eqs=Table[Collect[Coefficient[eqq/.c->360-12 a-6 b,x,n],r[n+5],Factor],{n,-6,M}];
Take[eqs,6]

lc=Table[Factor[D[Coefficient[eqq/.c->360-12 a-6 b,x,n],r[n+5]]],{n,-6,M}]
Length[lc]-Meqs

rvar=Table[r[n],{n,-1,M+5}]
kvar={k[1],k[3],k[4]}

Шестое уравнение – всегда резонанс, поэтому нас опять интересуют точки пересечения трех (а не четырех) прямых.

lines=Factor[lc]

points=Reap[Do[ss=Solve[{lines[[i]],lines[[j]],lines[[k]],lines[[h]]}==0,{a,b}];
If[ss=={},,Sow[{{a,b},{i,j,k,h}}/.ss[[1]]]],{i,1,Meqs},{j,i+1,Meqs},{k,j+1,Meqs},{h,k+1,Meqs}]][[2,1]]

P=Length[points]

ContourPlot[lines==0,{a,-10,70},{b,-20,80},
ContourStyle->Black,
ImageSize->400,
RotateLabel->False,
FrameLabel->{
Style["a",FontSize->20,FontFamily->"Times",FontSlant->Italic],
Style["b",FontSize->20,FontFamily->"Times",FontSlant->Italic]},
Epilog->{Blue,PointSize[0.025],Point[#[[1]]]&/@{points[[5]],points[[7]],
points[[8]],points[[9]]},Red,PointSize[0.015],Point[#[[1]]]&/@points}]

Cлучай 1: пусто

case=1;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[2]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 2: пусто

case=2;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[2]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 3: пусто

case=3;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[2]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 4: пусто

case=4;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[2]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 5: Fif-II

case=5;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[2]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]


Solve[gg==0,kvar]
Eq/.abru/.%[[1]]

Cлучай 6: пусто

case=6;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[2]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]

Cлучай 7: Fif-III

case=7;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[2]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]


Solve[gg==0,kvar]
Eq/.abru/.%[[1]]

Cлучай 8: Fif-IV ?? ((Subscript[k, 2]) должно быть произвольным...)

case=8;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[2]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]


Solve[gg==0,kvar]
Eq/.abru/.%[[1]]

Cлучай 9: Fif-I

case=9;
points[[case]]
abru=Thread[{a,b}->points[[case,1]]]

Eqs=eqs/.abru;
Length[%]
reseqs=eqs[[#]]&/@points[[case,2]]/.abru;
Length[%]
eeqs=Complement[Eqs,reseqs];
Length[%]

resvar=Union[r[#-2]&/@points[[case,2]],{k[2]}]
vvar=Complement[rvar,resvar]

ss=Solve[eeqs==0,vvar];
Length[%]

Factor[Flatten[CoefficientList[Factor[reseqs/.ss[[1]]],resvar]]];
gg=GroebnerBasis[%,kvar]


Solve[gg==0,kvar]
Eq/.abru/.%[[1]]

Операторные представления [L,A]=ϵ

.  L=(D^2)-2 y,  deg A=3 ⇒ P-I

Хорошо известное представление для P-I.

L[p_]:=D[p,x,x]-k y[x] p
eq:=L[A[p[x]]]-A[L[p[x]]]-ϵ p[x]

A[p_]:=D[p,x,x,x]+a2[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p

Collect[eq,{p[x], Derivative[_][p][x]},Factor]
Coefficient[eq,D[p[x],{x,3}]]

Можно положить (Subscript[a, 2])=0, за счет прибавления L к A.

A[p_]:=D[p,x,x,x]+a1[x]D[p,x]+a0[x]p
Coefficient[eq,D[p[x],{x,3}]]
Coefficient[eq,D[p[x],{x,2}]]
Solve[Integrate[%,x]==0,a1[x]][[1]]

A[p_]:=D[p,x,x,x]-(3/2) k (y[x]+a1)D[p,x]+a0[x]p
Coefficient[eq,D[p[x],{x,2}]]
Coefficient[eq,D[p[x],{x,1}]]
Solve[Integrate[%,x]==0,a0[x]][[1]]

Произвольную постоянную можно не писать, за счет прибавления 1 к A. Уточняем коэффициенты, сравнивая с P-I.

A[p_]:=D[p,x,x,x]-(3/2) k (y[x]+a1)D[p,x]-(3/4) k y'[x]p
Expand[-4/k eq/p[x]]

Integrate[%,x]+c
%/.{k->2,a1->0,ϵ->1/2,c->0}

Окончательный ответ для P-I:

L[p_]:=D[p,x,x]-2 y[x] p
A[p_]:=2D[p,x,x,x]-6 y[x]D[p,x]-3 y'[x]p
Factor[-(1/(p[x]))(L[A[p[x]]]-A[L[p[x]]]-p[x])]
Integrate[%,x]

.  L=(D^2)-2 y,  deg A=5   ⇒ F-V

L[p_]:=D[p,x,x]-k y[x] p
eq:=L[A[p[x]]]-A[L[p[x]]]-ϵ p[x]

A[p_]:=D[p,{x,5}]+a4[x]D[p,x,x,x,x]+a3[x]D[p,x,x,x]+a2[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p

Collect[eq,{p[x], Derivative[_][p][x]},Factor];
Coefficient[eq,D[p[x],{x,5}]]

Постоянные при (D^4),(D^2) и (D^0) можно не писать – они уничтожаются добавкой степеней L.

A[p_]:=D[p,{x,5}]+a3[x]D[p,x,x,x]+a2[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p
Coefficient[eq,D[p[x],{x,5}]]
Coefficient[eq,D[p[x],{x,4}]]
Solve[Integrate[%,x]==0,a3[x]][[1]]

A[p_]:=D[p,{x,5}]-(5/2) k (y[x]+a3)D[p,x,x,x]+a2[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p
Coefficient[eq,D[p[x],{x,4}]]
Coefficient[eq,D[p[x],{x,3}]]
Solve[Integrate[%,x]==0,a2[x]][[1]]

A[p_]:=D[p,{x,5}]-(5/2) k (y[x]+a3)D[p,x,x,x]-(15/4) k y'[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p
Coefficient[eq,D[p[x],{x,3}]]
Coefficient[eq,D[p[x],{x,2}]]
Solve[Integrate[%,x]==0,a1[x]][[1]]

A[p_]:=D[p,{x,5}]-(5/2) k (y[x]+a3)D[p,x,x,x]-(15/4) k y'[x]D[p,x,x]+(5/8) (6 a3 (k^2) y[x]+3 (k^2) ((y[x])^2)-5 k y''[x]+a1)D[p,x]+a0[x]p
Coefficient[eq,D[p[x],{x,2}]]
Coefficient[eq,D[p[x],{x,1}]]
Solve[Integrate[%,x]==0,a0[x]][[1]]

Сравниваем то, что осталось с F-V.

A[p_]:=D[p,{x,5}]-(5/2) k (y[x]+a3)D[p,x,x,x]-(15/4) k y'[x]D[p,x,x]+(5/8) (6 a3 (k^2) y[x]+3 (k^2) ((y[x])^2)-5 k y''[x]+a1)D[p,x]+(15/16) (2 a3 (k^2) y'[x]+2 (k^2) y[x] y'[x]-k Derivative[3][y][x])p

Expand[-16/k Integrate[eq/p[x],x]+c]
F5
%%-%/.{k->2,a3->0,a1->-α/10,ϵ->κ/8,c->β}

Окончательное представление для F-V.

L[p_]:=D[p,x,x]-2 y[x] p
A[p_]:=8D[p,{x,5}]-40 y[x]D[p,x,x,x]-60 y'[x]D[p,x,x]-(50 y''[x]-60 ((y[x])^2)+(α/2))D[p,x]-15 (Derivative[3][y][x]-4 y[x] y'[x])p

Expand[(L[A[p[x]]]-A[L[p[x]]]-κ p[x])/p[x]]

Expand[-Integrate[%,x]+β]
%-F5

.  L=(D^2)-2 y,  deg A=3, A – ПДО  ⇒  ((Subscript[1, a=4])),  Fif-III

Ищем A в виде ПДО специального вида. Используем тождество, чтобы упростить интегралы. P,Q должны быть волновыми функциями L, отвечающими одному и тому же значению λ=μ.

Clear[P,Q]
L[p_]:=D[p,x,x]-2 y[x]p
Expand[D[∫L[Q[x]]p[x]\[DifferentialD]x+Q[x]p'[x]-Q'[x]p[x],x]-D[∫Q[x]L[p[x]]\[DifferentialD]x,x]]

A[p_]:=D[p,x,x,x]+a2[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p +P[x]Integrate[Q[x]p,x]

L[A[p[x]]]-A[L[p[x]]]-ϵ p[x]
ExpandAll[%/.∫Q[x] L[p[x]]\[DifferentialD]x->∫L[Q[x]]p[x]\[DifferentialD]x+Q[x]p'[x]-Q'[x]p[x]]

PQrule={P''[x]->(2y[x]-μ)P[x],Q''[x]->(2y[x]-μ)Q[x]};

eq:=Collect[ExpandAll[
Expand[L[A[p[x]]]-A[L[p[x]]]-ϵ p[x]/.∫Q[x] L[p[x]]\[DifferentialD]x->∫L[Q[x]]p[x]\[DifferentialD]x+Q[x]p'[x]-Q'[x]p[x]]/.PQrule],{p[x], Derivative[_][p][x]},Factor]

eq

Coefficient[eq,p'''[x]]

Постоянные при (D^2) и (D^0) можно не писать – они уничтожаются добавкой степеней L.

A[p_]:=D[p,x,x,x]+a1[x]D[p,x]+a0[x]p +P[x]Integrate[Q[x]p,x]

Coefficient[eq,p''[x]]
Solve[Integrate[%,x]==0,a1[x]][[1]]

A[p_]:=D[p,x,x,x]-3(y[x]+a1)D[p,x]+a0[x]p +P[x]Integrate[Q[x]p,x]

Coefficient[eq,p'[x]]
Solve[Integrate[%,x]==0,a0[x]][[1]]

A[p_]:=D[p,x,x,x]-3(y[x]+a1)D[p,x]-(3/2) y'[x]p +P[x]Integrate[Q[x]p,x]
Factor[-2eq/p[x]]
eq1=Integrate[%,x]+c0

Сопоставляем с

y''=6(y^2)+x-2g,   2g g''=(((g'))^2)+2(a y+b)(g^2)-(c^2)

eqyg1=-y''[x]+6((y[x])^2)+x-2g[x]
eqyg2=-2g[x]g''[x]+((g'[x])^2)+2(a y[x]+b)((g[x])^2)-(c^2)

G=2P[x]Q[x];
w=Q'[x]P[x]-Q[x] P'[x];
D[w,x]/.PQrule
Factor[-2G D[G,x,x]+((D[G,x])^2)+4(2y[x]-μ)(G^2)-4(w^2)/.PQrule]

eqyg1-eq1/.{a1->0,g[x]->G,ϵ->1/2,c0->0}
Factor[eqyg2/.{g[x]->G,g'[x]->D[G,x],g''[x]->D[G,x,x],c->2 w,a->4,b->-2μ}/.PQrule]

Итак, ответ:

L[p_]:=D[p,x,x]-2 y[x]p
A[p_]:=2D[p,x,x,x]-6y[x]D[p,x]-3 y'[x]p +P[x]Integrate[Q[x]p,x]
PQrule={P''[x]->(2y[x]-μ)P[x],Q''[x]->(2y[x]-μ)Q[x]};
G=P[x]Q[x];
w=P[x]Q'[x]-P'[x]Q[x];
D[w,x]/.PQrule

Expand[D[∫L[Q[x]]p[x]\[DifferentialD]x+Q[x]p'[x]-Q'[x]p[x],x]-D[∫Q[x]L[p[x]]\[DifferentialD]x,x]]

L[A[p[x]]]-A[L[p[x]]]-p[x];

e1=Integrate[Factor[-1/p[x]
ExpandAll[%/.∫Q[x] L[p[x]]\[DifferentialD]x->∫L[Q[x]]p[x]\[DifferentialD]x+Q[x]p'[x]-Q'[x]p[x]/.PQrule]],x]

E1=-y''[x]+6((y[x])^2)+x-2g[x]
E2=-2g[x]g''[x]+((g'[x])^2)+4(2 y[x]-μ)((g[x])^2)-(c^2)

e1-(E1/.g[x]->G)
Factor[E2/.{g[x]->G,g'[x]->D[G,x],g''[x]->D[G,x,x],c->w}/.PQrule]

E3=Collect[D[E2,x]/(2g[x]),g'[x],Factor]
gys=Solve[E1==0,g[x]][[1]]
Ey=Collect[-2E3/.D[gys,x,x,x]/.D[gys,x]/.gys,{Derivative[5][y][x],Derivative[3][y][x],y''[x]},Factor]

Fif3= -Derivative[5][y][x]+20y[x]y'''[x]+40y'[x]y''[x]-120((y[x])^2)y'[x]+(λ x+α)y'[x]+2λ y[x]+κ;

Expand[
(Ey/.{y[x]->y[x]+μ/5,Derivative[j_][y][x]:>Derivative[j][y][x]})-(Fif3/.{λ->-4, α->24/5(μ^2), κ->12/5μ})
]

.  L=(D^3)-3 (y+a) D-(3/2) y',  deg A=4  ⇒ F-VI

L[p_]:=D[p,x,x,x]-2k (y[x]+a)D[p,x]-s y'[x] p
eq:=L[A[p[x]]]-A[L[p[x]]]-ϵ p[x]

A[p_]:=D[p,x,x,x,x]+a3[x]D[p,x,x,x]+a2[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p

Collect[eq,{p[x], Derivative[_][p][x]},Factor]
Coefficient[eq,D[p[x],{x,5}]]

Можно положить (Subscript[a, 3])=0, за счет прибавления L к M.

A[p_]:=D[p,x,x,x,x]+a2[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p
Coefficient[eq,D[p[x],{x,5}]]
Coefficient[eq,D[p[x],{x,4}]]
Solve[Integrate[%,x]==0,a2[x]][[1]]

A[p_]:=D[p,x,x,x,x]-((8k)/3)(y[x]+a2)D[p,x,x]+a1[x]D[p,x]+a0[x]p
Coefficient[eq,D[p[x],{x,4}]]
Coefficient[eq,D[p[x],{x,3}]]
Factor[Solve[Integrate[%,x]==0,a1[x]][[1]]]

A[p_]:=D[p,x,x,x,x]-((8k)/3)(y[x]+a2)D[p,x,x]-(4/3) ((k+s) y'[x]+a1)D[p,x]+a0[x]p
Coefficient[eq,D[p[x],{x,3}]]
Coefficient[eq,D[p[x],{x,2}]]
Factor[Solve[Integrate[%,x]==0,a0[x]][[1]]]

A[p_]:=D[p,x,x,x,x]-((8k)/3)(y[x]+a2)D[p,x,x]-(4/3) ((k+s) y'[x]+a1)D[p,x]-(2/9) (8 a (k^2) y[x]-16 a2 (k^2) y[x]-4 (k^2) ((y[x])^2)+2 k y''[x]+3 s y''[x]+a0)p

Coefficient[eq,p''[x]]
yeq1=Collect[Coefficient[eq,p'[x]],Derivative[_][y][x],Factor]
yeq0=Collect[Integrate[Coefficient[eq,p[x]],x]+c,{Derivative[_][y][x],c,ϵ},Factor]

Если k≠s, то первое уравнение автономно. Полагаем s=k, (Subscript[a, 1])=0. Сравниваем вторе уравнение с F-VI.

yeq1/.{s->k,a1->0}
Collect[9/k yeq0/.{s->k,a1->0},{Derivative[_][y][x],c,ϵ},Factor]
Collect[%//.{a->-2a2,k->3/2,c->β/6,ϵ->-κ/6,a2->-α/72},Derivative[_][y][x],Expand]
%-F6

Окончательное представление для F-VI.

rr={s->k,a1->0,a->-2a2,k->3/2,c->β/6,ϵ->-κ/6,a2->-α/72,a0->0};
Collect[L[p[x]]//.rr,Derivative[_][p][x],Expand]
Collect[A[p[x]]//.rr,Derivative[_][p][x],Expand]

L[p_]:=2D[p,x,x,x]-(6y[x]+μ)D[p,x]-3 y'[x] p
A[p_]:=3D[p,x,x,x,x]-(12y[x]-μ)D[p,x,x]-12  y'[x]D[p,x]-(5y''[x]-6 ((y[x])^2)+4μ y[x])p

Expand[(L[A[p[x]]]-A[L[p[x]]]+κ p[x])/p[x]]

Expand[Integrate[%,x]+β]
Expand[F6/.α->6μ]
Expand[%%-%]

.  L=(D^3)-2k (y+a) D-s y',  deg A=5     ⇒ пусто

L[p_]:=D[p,x,x,x]-2k (y[x]+a)D[p,x]-s y'[x]p
eq:=L[M[p[x]]]-M[L[p[x]]]-ϵ p[x]

M[p_]:=D[p,{x,5}]+a4[x]D[p,x,x,x,x]+a3[x]D[p,x,x,x]+a2[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p

Collect[eq,{p[x], Derivative[_][p][x]},Factor];
Coefficient[eq,D[p[x],{x,6}]]

M[p_]:=D[p,{x,5}]+a4 D[p,x,x,x,x]+a3[x]D[p,x,x,x]+a2[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p
Coefficient[eq,D[p[x],{x,6}]]
Coefficient[eq,D[p[x],{x,5}]]
Solve[Integrate[%,x]==0,a3[x]][[1]]

M[p_]:=D[p,{x,5}]+a4 D[p,x,x,x,x]-(10/3)k(y[x]+a3)D[p,x,x,x]+a2[x]D[p,x,x]+a1[x]D[p,x]+a0[x]p

Coefficient[eq,D[p[x],{x,5}]]
Coefficient[eq,D[p[x],{x,4}]]
Factor[Solve[Integrate[%,x]==0,a2[x]][[1]]]

M[p_]:=D[p,{x,5}]+a4 D[p,x,x,x,x]-(10/3)k(y[x]+a3)D[p,x,x,x]+(1/3) (-8 a4 k y[x]-10 k y'[x]-5 s y'[x]+a2)D[p,x,x]+a1[x]D[p,x]+a0[x]p

Coefficient[eq,D[p[x],{x,4}]]
Coefficient[eq,D[p[x],{x,3}]]
Factor[Solve[Integrate[%,x]==0,a1[x]][[1]]]

M[p_]:=D[p,{x,5}]+a4 D[p,x,x,x,x]-(10/3)k(y[x]+a3)D[p,x,x,x]+(1/3) (-8 a4 k y[x]-10 k y'[x]-5 s y'[x]+a2)D[p,x,x]+(1/9) (-20 a (k^2) y[x]+60 a3 (k^2) y[x]+20 (k^2) ((y[x])^2)-12 a4 k y'[x]-12 a4 s y'[x]-20 k y''[x]-15 s y''[x]+a1)D[p,x]+a0[x]p

Coefficient[eq,D[p[x],{x,3}]]
Coefficient[eq,D[p[x],{x,2}]]
Factor[Solve[Integrate[%,x]==0,a0[x]][[1]]]

M[p_]:=D[p,{x,5}]+a4 D[p,x,x,x,x]-(10/3)k(y[x]+a3)D[p,x,x,x]+(1/3) (-8 a4 k y[x]-10 k y'[x]-5 s y'[x]+a2)D[p,x,x]+(1/9) (-20 a (k^2) y[x]+60 a3 (k^2) y[x]+20 (k^2) ((y[x])^2)-12 a4 k y'[x]-12 a4 s y'[x]-20 k y''[x]-15 s y''[x]+a1)D[p,x]-(2/9) (2 a2 k y[x]+8 a a4 (k^2) y[x]-4 a4 (k^2) ((y[x])^2)+5 a k s y'[x]-15 a3 k s y'[x]-10 k s y[x] y'[x]+2 a4 k y''[x]+3 a4 s y''[x]+5 s Derivative[3][y][x]+a0)p

Coefficient[eq,D[p[x],{x,2}]]
yeq1=Collect[Integrate[Coefficient[eq,D[p[x],{x,1}]],x]+c0,Derivative[_][y][x],Factor]
yeq0=Collect[Integrate[Coefficient[eq,p[x]],x]+c,{Derivative[_][y][x],c,ϵ},Factor]

.  L=(D^3)-2k (y+a) D-s y',  deg A=2, A – ПДО   ⇒ ??

L[P_]:=D[P,x,x,x]-2k(y[x]+a)D[P,x]-s y'[x]P
Lt[P_]:=-D[P,x,x,x]+2k(y[x]+a)D[P,x]+(2k-s) y'[x]P

Expand[q[x]L[P[x]]-Lt[q[x]]P[x]-D[q[x]P''[x]-q'[x]P'[x]+q''[x]P[x]-2a k q[x]P[x]-2k y[x]q[x]P[x],x]]

pqrule={
p'''[x]->2k(y[x]+a)p'[x]+s y'[x]p[x]+α p[x],
q'''[x]->2k(y[x]+a)q'[x]+(2k-s)y'[x]q[x]-α q[x]};

eq:=Collect[ExpandAll[
Expand[L[M[P[x]]]-M[L[P[x]]]-ϵ P[x]/.∫q[x] L[P[x]]\[DifferentialD]x->∫Lt[q[x]]P[x]\[DifferentialD]x+q[x]P''[x]-q'[x]P'[x]+q''[x]P[x]-2a k q[x]P[x]-2k y[x]q[x]P[x]]/.pqrule],{P[x], Derivative[_][P][x]},Factor]

M[P_]:=D[P,x,x]+a1[x]D[P,x]+a0[x]P+p[x]Integrate[q[x]P,x]
eq

Coefficient[%,P''''[x]]
Coefficient[%%,P'''[x]]

M[P_]:=D[P,x,x]+a1 D[P,x]+a0[x]P+p[x]Integrate[q[x]P,x]
eq;

Coefficient[%,P'''[x]]
Coefficient[%%,P''[x]]
Solve[Integrate[%,x]==0,a0[x]][[1]]

M[P_]:=D[P,x,x]+a1 D[P,x]-(4/3) k (y[x]+a0)P+p[x]Integrate[q[x]P,x]
eq;

Coefficient[%,P''[x]]
eq1=Integrate[Coefficient[%%,P'[x]],x]+c1
eq0=Integrate[Coefficient[%%%,P[x]],x]+c0

pqrule

D[eq1,x]

Матричное (Subscript[P, 1]) и Fif-II

Fif-II является (почти эквивалентным) следствием (Subscript[P, 1]) в матрицах 2×2, с нулевым свободным членом.

Clear[P,Q,w]

U={{u[x]+h[x],e[x]},
{f[x],u[x]-h[x]}};

Expand[U.U-2u[x]U+(((u[x])^2)-(((h[x])^2)+e[x]f[x]))IdentityMatrix[2]]

Expand[D[U,x,x]-6 U.U-x{{1,0},{0,1}}]

uefh=Solve[%==0,D[{u[x],e[x],f[x],h[x]},x,x]][[1]]

G=-3(((h[x])^2)+e[x]f[x]);
Factor[-u''[x]+6((u[x])^2)+x-2G/.uefh]
Factor[-D[G,x,x,x]+48 u[x]D[G,x]+24 u'[x]G/.D[uefh,x]/.uefh]

w[a_,b_]:=a D[b,x]-D[a,x]b

Factor[-(2G D[G,x,x]-((D[G,x])^2)-48 u[x](G^2))+36 w[e[x],h[x]] w[f[x],h[x]]-9((w[e[x],f[x]])^2)/.uefh]

Если матрица диагональна (p=q=0), то система сводится к паре (Subscript[P, 1]).

y12={y1''[x]->6 ((y1[x])^2)+x,y2''[x]->6 ((y2[x])^2)+x};

G=-3/4(((y2[x]-y1[x]))^2);
Y=(y1[x]+y2[x])/2;

Factor[-D[Y,x,x]+6(Y^2)+x-2G/.y12]
Factor[-D[G,x,x,x]+48 Y D[G,x]+24 D[Y,x]G/.D[y12,x]/.y12]
Factor[-2G D[G,x,x]+((D[G,x])^2)+48 Y (G^2)/.y12]